home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / mbe.scm < prev    next >
Text File  |  1999-04-19  |  13KB  |  444 lines
  1. ;;;; "mbe.scm" "Macro by Example" (Eugene Kohlbecker, R4RS)
  2. ;;; From: Dorai Sitaram, dorai@cs.rice.edu, 1991, 1999
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; revised Dec. 6, 1993 to R4RS syntax (if not semantics).
  21. ;;; revised Mar. 2 1994 for SLIB (jaffer@ai.mit.edu).
  22. ;;; corrections, Apr. 24, 1997.
  23. ;;; corr., Jan. 30, 1999. (mflatt@cs.rice.edu, dorai@cs.rice.edu)
  24.  
  25. ;;; A vanilla implementation of hygienic macro-by-example as described
  26. ;;; by Eugene Kohlbecker and in R4RS Appendix.  This file requires
  27. ;;; defmacro.
  28.  
  29. (require 'common-list-functions)    ;nconc, some, every
  30. ;(require 'rev2-procedures)        ;append! alternate for nconc
  31. (require 'rev4-optional-procedures)    ;list-tail
  32. (require 'defmacroexpand)
  33.  
  34. (define hyg:rassq
  35.   (lambda (k al)
  36.     (let loop ((al al))
  37.       (if (null? al) #f
  38.     (let ((c (car al)))
  39.       (if (eq? (cdr c) k) c
  40.         (loop (cdr al))))))))
  41.  
  42. (define hyg:tag
  43.   (lambda (e kk al)
  44.     (cond ((pair? e)
  45.         (let* ((a-te-al (hyg:tag (car e) kk al))
  46.             (d-te-al (hyg:tag (cdr e) kk (cdr a-te-al))))
  47.           (cons (cons (car a-te-al) (car d-te-al))
  48.         (cdr d-te-al))))
  49.       ((vector? e)
  50.     (list->vector
  51.       (hyg:tag (vector->list e) kk al)))
  52.       ((symbol? e)
  53.     (cond ((eq? e '...) (cons '... al))
  54.       ((memq e kk) (cons e al))
  55.       ((hyg:rassq e al) =>
  56.         (lambda (c)
  57.           (cons (car c) al)))
  58.       (else
  59.         (let ((te (gentemp)))
  60.           (cons te (cons (cons te e) al))))))
  61.       (else (cons e al)))))
  62.  
  63. ;;untagging
  64.  
  65. (define hyg:untag
  66.   (lambda (e al tmps)
  67.     (if (pair? e)
  68.       (let ((a (hyg:untag (car e) al tmps)))
  69.     (if (list? e)
  70.       (case a
  71.         ((quote) (hyg:untag-no-tags e al))
  72.         ((quasiquote) (list a (hyg:untag-quasiquote (cadr e) al tmps)))
  73.         ((if begin)
  74.           `(,a ,@(map (lambda (e1)
  75.                 (hyg:untag e1 al tmps)) (cdr e))))
  76.         ((set! define)
  77.           `(,a ,(hyg:untag-vanilla (cadr e) al tmps)
  78.          ,@(map (lambda (e1)
  79.               (hyg:untag e1 al tmps)) (cddr e))))
  80.         ((lambda) (hyg:untag-lambda (cadr e) (cddr e) al tmps))
  81.         ((letrec) (hyg:untag-letrec (cadr e) (cddr e) al tmps))
  82.         ((let)
  83.           (let ((e2 (cadr e)))
  84.         (if (symbol? e2)
  85.           (hyg:untag-named-let e2 (caddr e) (cdddr e) al tmps)
  86.           (hyg:untag-let e2 (cddr e) al tmps))))
  87.         ((let*) (hyg:untag-let* (cadr e) (cddr e) al tmps))
  88.         ((do) (hyg:untag-do (cadr e) (caddr e) (cdddr e) al tmps))
  89.         ((case)
  90.           `(case ,(hyg:untag-vanilla (cadr e) al tmps)
  91.          ,@(map
  92.              (lambda (c)
  93.                `(,(hyg:untag-vanilla (car c) al tmps)
  94.               ,@(hyg:untag-list (cdr c) al tmps)))
  95.              (cddr e))))
  96.         ((cond)
  97.           `(cond ,@(map
  98.              (lambda (c)
  99.                (hyg:untag-list c al tmps))
  100.              (cdr e))))
  101.         (else (cons a (hyg:untag-list (cdr e) al tmps))))
  102.       (cons a (hyg:untag-list* (cdr e) al tmps))))
  103.       (hyg:untag-vanilla e al tmps))))
  104.  
  105. (define hyg:untag-list
  106.   (lambda (ee al tmps)
  107.     (map (lambda (e)
  108.        (hyg:untag e al tmps)) ee)))
  109.  
  110. (define hyg:untag-list*
  111.   (lambda (ee al tmps)
  112.     (let loop ((ee ee))
  113.       (if (pair? ee)
  114.     (cons (hyg:untag (car ee) al tmps)
  115.       (loop (cdr ee)))
  116.     (hyg:untag ee al tmps)))))
  117.  
  118. (define hyg:untag-no-tags
  119.   (lambda (e al)
  120.     (cond ((pair? e)
  121.         (cons (hyg:untag-no-tags (car e) al)
  122.           (hyg:untag-no-tags (cdr e) al)))
  123.       ((vector? e)
  124.     (list->vector
  125.       (hyg:untag-no-tags (vector->list e) al)))
  126.       ((not (symbol? e)) e)
  127.       ((assq e al) => cdr)
  128.       (else e))))
  129.  
  130. (define hyg:untag-quasiquote
  131.   (lambda (form al tmps)
  132.     (let qq ((x form) (level 0))
  133.       (cond
  134.        ((pair? x)
  135.     (let ((first (qq (car x) level)))
  136.       (cond
  137.        ((and (eq? first 'unquote) (list? x))
  138.         (let ((rest (cdr x)))
  139.           (if (or (not (pair? rest))
  140.               (not (null? (cdr rest))))
  141.           (slib:error 'unquote 'takes-exactly-one-expression)
  142.           (if (zero? level)
  143.               (list 'unquote (hyg:untag (car rest) al tmps))
  144.               (cons first (qq rest (sub1 level)))))))
  145.        ((and (eq? first 'quasiquote) (list? x))
  146.         (cons 'quasiquote (qq (cdr x) (add1 level))))
  147.        ((and (eq? first 'unquote-splicing) (list? x))
  148.         (slib:error 'unquote-splicing 'invalid-context-within-quasiquote))
  149.        ((pair? first)
  150.         (let ((car-first (qq (car first) level)))
  151.           (if (and (eq? car-first 'unquote-splicing)
  152.                (list? first))
  153.           (let ((rest (cdr first)))
  154.             (if (or (not (pair? rest))
  155.                 (not (null? (cdr rest))))
  156.             (slib:error 'unquote-splicing
  157.                     'takes-exactly-one-expression)
  158.             (list (list 'unquote-splicing
  159.                     (if (zero? level)
  160.                     (hyg:untag (cadr rest) al tmps)
  161.                     (qq (cadr rest) (sub1 level)))
  162.                     (qq (cdr x) level)))))
  163.           (cons (cons car-first
  164.                   (qq (cdr first) level))
  165.             (qq (cdr x) level)))))
  166.        (else
  167.         (cons first (qq (cdr x) level))))))
  168.        ((vector? x)
  169.     (list->vector
  170.      (qq (vector->list x) level)))
  171.        (else (hyg:untag-no-tags x al))))))
  172.  
  173. (define hyg:untag-lambda
  174.   (lambda (bvv body al tmps)
  175.     (let ((tmps2 (nconc (hyg:flatten bvv) tmps)))
  176.       `(lambda ,bvv
  177.      ,@(hyg:untag-list body al tmps2)))))
  178.  
  179. (define hyg:untag-letrec
  180.   (lambda (varvals body al tmps)
  181.     (let ((tmps (nconc (map car varvals) tmps)))
  182.       `(letrec
  183.      ,(map
  184.         (lambda (varval)
  185.           `(,(car varval)
  186.          ,(hyg:untag (cadr varval) al tmps)))
  187.         varvals)
  188.      ,@(hyg:untag-list body al tmps)))))
  189.  
  190. (define hyg:untag-let
  191.   (lambda (varvals body al tmps)
  192.     (let ((tmps2 (nconc (map car varvals) tmps)))
  193.       `(let
  194.      ,(map
  195.          (lambda (varval)
  196.            `(,(car varval)
  197.           ,(hyg:untag (cadr varval) al tmps)))
  198.          varvals)
  199.      ,@(hyg:untag-list body al tmps2)))))
  200.  
  201. (define hyg:untag-named-let
  202.   (lambda (lname varvals body al tmps)
  203.     (let ((tmps2 (cons lname (nconc (map car varvals) tmps))))
  204.       `(let ,lname
  205.      ,(map
  206.          (lambda (varval)
  207.            `(,(car varval)
  208.           ,(hyg:untag (cadr varval) al tmps)))
  209.          varvals)
  210.      ,@(hyg:untag-list body al tmps2)))))
  211.  
  212. (define hyg:untag-let*
  213.   (lambda (varvals body al tmps)
  214.     (let ((tmps2 (nconc (nreverse (map car varvals)) tmps)))
  215.       `(let*
  216.      ,(let loop ((varvals varvals)
  217.               (i (length varvals)))
  218.         (if (null? varvals) '()
  219.           (let ((varval (car varvals)))
  220.         (cons `(,(car varval)
  221.              ,(hyg:untag (cadr varval)
  222.                 al (list-tail tmps2 i)))
  223.           (loop (cdr varvals) (- i 1))))))
  224.      ,@(hyg:untag-list body al tmps2)))))
  225.  
  226. (define hyg:untag-do
  227.   (lambda (varinistps exit-test body al tmps)
  228.     (let ((tmps2 (nconc (map car varinistps) tmps)))
  229.       `(do
  230.      ,(map
  231.         (lambda (varinistp)
  232.           (let ((var (car varinistp)))
  233.         `(,var ,@(hyg:untag-list (cdr varinistp) al
  234.                (cons var tmps)))))
  235.         varinistps)
  236.      ,(hyg:untag-list exit-test al tmps2)
  237.      ,@(hyg:untag-list body al tmps2)))))
  238.  
  239. (define hyg:untag-vanilla
  240.   (lambda (e al tmps)
  241.     (cond ((pair? e)
  242.         (cons (hyg:untag-vanilla (car e) al tmps)
  243.           (hyg:untag-vanilla (cdr e) al tmps)))
  244.       ((vector? e)
  245.     (list->vector
  246.       (hyg:untag-vanilla (vector->list e) al tmps)))
  247.       ((not (symbol? e)) e)
  248.       ((memq e tmps) e)
  249.       ((assq e al) => cdr)
  250.       (else e))))
  251.  
  252. (define hyg:flatten
  253.   (lambda (e)
  254.     (let loop ((e e) (r '()))
  255.       (cond ((pair? e) (loop (car e)
  256.                  (loop (cdr e) r)))
  257.         ((null? e) r)
  258.         (else (cons e r))))))
  259.  
  260. ;;;; End of hygiene filter.
  261.  
  262.  
  263. ;;; finds the leftmost index of list l where something equal to x
  264. ;;; occurs
  265. (define mbe:position
  266.   (lambda (x l)
  267.     (let loop ((l l) (i 0))
  268.       (cond ((not (pair? l)) #f)
  269.         ((equal? (car l) x) i)
  270.         (else (loop (cdr l) (+ i 1)))))))
  271.  
  272. ;;; (mbe:append-map f l) == (apply append (map f l))
  273.  
  274. (define mbe:append-map
  275.   (lambda (f l)
  276.     (let loop ((l l))
  277.       (if (null? l) '()
  278.       (append (f (car l)) (loop (cdr l)))))))
  279.  
  280. ;;; tests if expression e matches pattern p where k is the list of
  281. ;;; keywords
  282. (define mbe:matches-pattern?
  283.   (lambda (p e k)
  284.     (cond ((mbe:ellipsis? p)
  285.        (and (or (null? e) (pair? e))
  286.         (let* ((p-head (car p))
  287.                (p-tail (cddr p))
  288.                (e-head=e-tail (mbe:split-at-ellipsis e p-tail)))
  289.           (and e-head=e-tail
  290.                (let ((e-head (car e-head=e-tail))
  291.                  (e-tail (cdr e-head=e-tail)))
  292.              (and (every
  293.                    (lambda (x) (mbe:matches-pattern? p-head x k))
  294.                    e-head)
  295.                   (mbe:matches-pattern? p-tail e-tail k)))))))
  296.       ((pair? p)
  297.        (and (pair? e)
  298.         (mbe:matches-pattern? (car p) (car e) k)
  299.         (mbe:matches-pattern? (cdr p) (cdr e) k)))
  300.       ((symbol? p) (if (memq p k) (eq? p e) #t))
  301.       (else (equal? p e)))))
  302.  
  303. ;;; gets the bindings of pattern variables of pattern p for
  304. ;;; expression e;
  305. ;;; k is the list of keywords
  306. (define mbe:get-bindings
  307.   (lambda (p e k)
  308.     (cond ((mbe:ellipsis? p)
  309.        (let* ((p-head (car p))
  310.           (p-tail (cddr p))
  311.           (e-head=e-tail (mbe:split-at-ellipsis e p-tail))
  312.           (e-head (car e-head=e-tail))
  313.           (e-tail (cdr e-head=e-tail)))
  314.          (cons (cons (mbe:get-ellipsis-nestings p-head k)
  315.              (map (lambda (x) (mbe:get-bindings p-head x k))
  316.               e-head))
  317.            (mbe:get-bindings p-tail e-tail k))))
  318.       ((pair? p)
  319.        (append (mbe:get-bindings (car p) (car e) k)
  320.          (mbe:get-bindings (cdr p) (cdr e) k)))
  321.       ((symbol? p)
  322.        (if (memq p k) '() (list (cons p e))))
  323.       (else '()))))
  324.  
  325. ;;; expands pattern p using environment r;
  326. ;;; k is the list of keywords
  327. (define mbe:expand-pattern
  328.   (lambda (p r k)
  329.     (cond ((mbe:ellipsis? p)
  330.        (append (let* ((p-head (car p))
  331.               (nestings (mbe:get-ellipsis-nestings p-head k))
  332.               (rr (mbe:ellipsis-sub-envs nestings r)))
  333.              (map (lambda (r1)
  334.                 (mbe:expand-pattern p-head (append r1 r) k))
  335.               rr))
  336.          (mbe:expand-pattern (cddr p) r k)))
  337.       ((pair? p)
  338.        (cons (mbe:expand-pattern (car p) r k)
  339.          (mbe:expand-pattern (cdr p) r k)))
  340.       ((symbol? p)
  341.        (if (memq p k) p
  342.          (let ((x (assq p r)))
  343.            (if x (cdr x) p))))
  344.       (else p))))
  345.  
  346. ;;; returns a list that nests a pattern variable as deeply as it
  347. ;;; is ellipsed
  348. (define mbe:get-ellipsis-nestings
  349.   (lambda (p k)
  350.     (let sub ((p p))
  351.       (cond ((mbe:ellipsis? p) (cons (sub (car p)) (sub (cddr p))))
  352.         ((pair? p) (append (sub (car p)) (sub (cdr p))))
  353.         ((symbol? p) (if (memq p k) '() (list p)))
  354.         (else '())))))
  355.  
  356. ;;; finds the subenvironments in r corresponding to the ellipsed
  357. ;;; variables in nestings
  358.  
  359. (define mbe:ellipsis-sub-envs
  360.   (lambda (nestings r)
  361.     (let ((sub-envs-list
  362.        (let loop ((r r) (sub-envs-list '()))
  363.          (if (null? r) (nreverse sub-envs-list)
  364.          (let ((c (car r)))
  365.            (loop (cdr r)
  366.              (if (mbe:contained-in? nestings (car c))
  367.                  (cons (cdr c) sub-envs-list)
  368.                  sub-envs-list)))))))
  369.       (case (length sub-envs-list)
  370.     ((0) #f)
  371.     ((1) (car sub-envs-list))
  372.     (else
  373.      (let loop ((sub-envs-list sub-envs-list) (final-sub-envs '()))
  374.        (if (some null? sub-envs-list) (nreverse final-sub-envs)
  375.            (loop (map cdr sub-envs-list)
  376.              (cons (mbe:append-map car sub-envs-list)
  377.                final-sub-envs)))))))))
  378.  
  379. ;;; checks if nestings v and y have an intersection
  380. (define mbe:contained-in?
  381.   (lambda (v y)
  382.     (if (or (symbol? v) (symbol? y)) (eq? v y)
  383.     (some (lambda (v_i)
  384.             (some (lambda (y_j)
  385.                     (mbe:contained-in? v_i y_j))
  386.                       y))
  387.               v))))
  388.  
  389. ;;; split expression e so that its second half matches with
  390. ;;; pattern p-tail
  391. (define mbe:split-at-ellipsis
  392.   (lambda (e p-tail)
  393.     (if (null? p-tail) (cons e '())
  394.       (let ((i (mbe:position (car p-tail) e)))
  395.     (if i (cons (butlast e (- (length e) i))
  396.             (list-tail e i))
  397.         (slib:error 'mbe:split-at-ellipsis 'bad-arg))))))
  398.  
  399. ;;; tests if x is an ellipsing pattern, i.e., of the form
  400. ;;; (blah ... . blah2)
  401. (define mbe:ellipsis?
  402.   (lambda (x)
  403.     (and (pair? x) (pair? (cdr x)) (eq? (cadr x) '...))))
  404.  
  405. ;define-syntax
  406.  
  407. (defmacro define-syntax (macro-name syn-rules)
  408.   (if (or (not (pair? syn-rules))
  409.     (not (eq? (car syn-rules) 'syntax-rules)))
  410.     (slib:error 'define-syntax 'not-an-r4rs-high-level-macro
  411.       macro-name syn-rules)
  412.     (let ((keywords (cons macro-name (cadr syn-rules)))
  413.        (clauses (cddr syn-rules)))
  414.       `(defmacro ,macro-name macro-arg
  415.      (let ((macro-arg (cons ',macro-name macro-arg))
  416.         (keywords ',keywords))
  417.        (cond ,@(map
  418.              (lambda (clause)
  419.                (let ((in-pattern (car clause))
  420.                   (out-pattern (cadr clause)))
  421.              `((mbe:matches-pattern? ',in-pattern macro-arg
  422.                  keywords)
  423.                 (let ((tagged-out-pattern+alist
  424.                     (hyg:tag
  425.                       ',out-pattern
  426.                       (nconc (hyg:flatten ',in-pattern)
  427.                     keywords) '())))
  428.                   (hyg:untag
  429.                 (mbe:expand-pattern
  430.                   (car tagged-out-pattern+alist)
  431.                   (mbe:get-bindings ',in-pattern macro-arg
  432.                     keywords)
  433.                   keywords)
  434.                 (cdr tagged-out-pattern+alist)
  435.                 '())))))
  436.              clauses)
  437.          (else (slib:error ',macro-name 'no-matching-clause
  438.              ',clauses))))))))
  439.  
  440. (define macro:eval slib:eval)
  441. (define macro:load slib:load)
  442. (provide 'macro)
  443. ;eof
  444.